home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / PASCAL / 0188.ZIP / ITRMXFER.INC < prev    next >
Text File  |  1985-02-20  |  10KB  |  370 lines
  1. const
  2.      SOH = 1;                          {Start Of Header}
  3.      EOT = 4;                          {End Of Transmission}
  4.      ACK = 6;                          {ACKnowledge}
  5.      NAK = $15;                        {Negative AcKnowledge}
  6.      CAN = $18;                        {CANcel}
  7.      MAXERRS = 10;                     {Maximum allowed errors}
  8.      L = 0;
  9.      H = 1;
  10. type
  11.      bytevec130 = array[1..133] of byte;
  12.  
  13. {*** variables used as globals in this source segment
  14.      (actually global to whole  source) ***}
  15. var
  16.    checksum : byte;
  17.    sector : bytevec130;
  18.    fname : bigstring;
  19.    response : string[1];
  20.    f : stream;
  21.    crcval,db,sb : integer;
  22.    p : parity_set;
  23.  
  24. procedure purge;
  25. begin
  26.      while cgetc(1) <> -1 do
  27.            ;
  28. end;
  29.  
  30. procedure ShowCrt(sec, try, tot : integer);
  31. type
  32.     str3 = string[3];
  33. var
  34.    i : integer;
  35.  
  36.      function ToString(n : integer) : str3;
  37.      var
  38.         s : str3;
  39.      begin
  40.           str(n,s);
  41.           ToString := s
  42.      end;
  43. begin
  44.      status(0,concat('Blk:', ToString(sec),
  45.                      ' Try:', ToString(try){,
  46.                      ' Errs:', ToString(tot)}))
  47. end;
  48.  
  49.  
  50. procedure updcrc(a : byte);
  51. begin
  52.    inline( $8A/$46/$04/        {MOV     AL,[BP+04]}
  53.            $8B/$1E/crcval/     {MOV     BX,crcval}
  54.            $B9/$08/$00/        {MOV     CX,0008}
  55. {loop0}    $D0/$E0/            {SHL     AL,1}
  56.            $D1/$D3/            {RCL     BX,1}
  57.            $73/$04/            {JNC     loop1}
  58.            $81/$F3/$21/$10/    {XOR     BX,$1021}
  59. {loop1}    $E2/$F4/            {LOOP    loop0}
  60.            $89/$1E/crcval)     {MOV     crcval,BX}
  61. end;
  62.  
  63. procedure SaveCommStatus;
  64. begin
  65.       p := parity;
  66.       db := dbits;
  67.       sb := stop_bits;
  68.       dbits        := 8;
  69.       parity       := none;
  70.       stop_bits    := 1;
  71.       update_uart
  72. end;
  73.  
  74. procedure recv_wcp;
  75. {receive a file using Ward Christensen's checksum protocol}
  76. label
  77.      99;
  78. var
  79.   j, firstchar, sectnum, sectcurr,
  80.    toterr, errors, sectcomp : integer;
  81.    ErrorFlag : boolean;
  82. begin
  83.      status(2, 'RECV XMODEM');
  84.      ErrorFlag := TRUE;
  85.      SaveCommStatus;
  86.      OpenTemp(1,3,80,8,2);
  87.      repeat
  88.            write('Enter a filename for download file (<cr> to abort): ');
  89.            readln(fname);
  90.            supcase(fname);
  91.            if length(fname) > 0 then
  92.               if exists(fname) then
  93.               begin
  94.                 write(fname, ' Exists. OK to overwrite it (Y/N)? ');
  95.                 readln(response);
  96.                 if upcase(response) = 'Y' then
  97.                    ErrorFlag := FALSE;
  98.               end
  99.               else ErrorFlag := FALSE
  100.      until (not ErrorFlag) or (length(fname) = 0);
  101.      CloseTemp;
  102.      if length(fname) > 0 then
  103.          f := fopen(fname,'w');
  104.      if length(fname) = 0 then
  105.         writeln(#13,#10,'ITERM --- user aborted receive.')
  106.      else if f = NIL then
  107.          writeln(#13,#10,'ITERM --- could not open ',fname, ' Aborting receive.');
  108.      if (f = NIL) or (length(fname) = 0) then
  109.         goto 99;
  110.      writeln('Ready to receive ', fname);
  111.      sectnum := 0;
  112.      errors := 0;
  113.      toterr := 0;
  114.      ShowCrt(0,0,0);
  115.      send(ord('C')); {request CRC}
  116.      repeat
  117.           ErrorFlag := FALSE;
  118.           repeat
  119.                firstchar := cgetc(10)
  120.           until (firstchar = SOH) or (firstchar = EOT) or (firstchar = -1);
  121.           if firstchar = -1 then
  122.              ErrorFlag := TRUE;
  123.           if firstchar = SOH then
  124.           begin
  125.                sectcurr := cgetc(1);
  126.                sectcomp := cgetc(1);
  127.                if (sectcurr + sectcomp) = 255 then
  128.                begin
  129.                     if sectcurr = (sectnum + 1) then
  130.                     begin
  131.                          crcval := 0;
  132.                          checksum := 0;
  133.                          for j := 1 to 128 do
  134.                          begin
  135.                               sector[j] := cgetc(1);
  136.                               updcrc(sector[j]);
  137.                               checksum := checksum + sector[j]
  138.                          end;
  139.                          sector[129] := cgetc(1);
  140.                          sector[130] := cgetc(1);
  141.                          updcrc(sector[129]);
  142.                          updcrc(sector[130]);
  143.                          if crcval = 0 then
  144.                          begin
  145.                               send(ACK);
  146.                               errors := 0;
  147.                               sectnum := sectcurr;
  148.                               ShowCrt(sectnum, errors, toterr);
  149.                               for j := 1 to 128 do
  150.                                   write(f^,sector[j])
  151.                          end
  152.                          else
  153.                              ErrorFlag := TRUE
  154.                     end
  155.                     else
  156.                     if sectcurr = sectnum then
  157.                     begin
  158.                        purge;
  159.                        send(ACK)
  160.                     end
  161.                     else
  162.                       ErrorFlag := TRUE
  163.                end
  164.                else
  165.                    ErrorFlag := TRUE
  166.           end;
  167.           if ErrorFlag then
  168.           begin
  169.                errors := errors + 1;
  170.                if sectnum > 0 then
  171.                   toterr := succ(toterr);
  172.                purge;
  173.                ShowCrt(sectnum, errors, toterr);
  174.                send(NAK)
  175.           end
  176.      until (firstchar = EOT) or (errors = MAXERRS);
  177.      if (firstchar = EOT) and (errors < MAXERRS) then
  178.      begin
  179.           send(ACK);
  180.           close(f^);
  181.           dispose(f);
  182.           writeln('DONE.')
  183.      end
  184.      else begin
  185.           send(CAN);
  186.           writeln('ABORTING: Error limit exceeded or unrecoverable error.');
  187.           close(f^);
  188.           erase(f^);
  189.           dispose(f)
  190.      end;
  191. 99:
  192.      status(0,' ');
  193.      status(2,'On-Line/Ready');
  194.      dbits        := db;
  195.      parity       := p;
  196.      stop_bits    := sb;
  197.      update_uart;
  198. end;
  199.  
  200. procedure SendAscii;
  201. var
  202.    f : stream;
  203.    b : byte;
  204.    fname : bigstring;
  205.    c : integer;
  206. begin
  207.      OpenTemp(10,5,60,12,2);
  208.      repeat
  209.            Write('Filename to transmit? ');
  210.            readln(fname);
  211.            f := fopen(fname, 'r');
  212.            if f = NIL then
  213.            begin
  214.                 Writeln('Can''t open: ',fname);
  215.                 WriteLn('Please try a different spelling, drive or disk.');
  216.                 WriteLn
  217.            end
  218.      until (f <> NIL) or (Length(fname) = 0);
  219.      CloseTemp;
  220.      if f <> NIL then
  221.      begin
  222.           Status(0,'Sending ASCII');
  223.           OpenTemp(1,3,80,20,1);
  224.           b := 0;
  225.           while (not eof(f^)) and (b <> 26)do
  226.           begin
  227.                read(f^,b);
  228.                if (b <> 26) and (b <> 10) then
  229.                begin
  230.                   send(b);
  231.                   c := cgetc(1);
  232.                   if c = 19 then
  233.                      while cgetc(0) <> 17 do ;
  234.                   if c <> -1 then
  235.                      write(chr(c and $7F));
  236.                   if c = 13 then
  237.                      writeln
  238.                end
  239.           end;
  240.           CloseTemp;
  241.           close(f^);
  242.           dispose(f);
  243.           Status(0,' ')
  244.      end
  245. end;
  246.  
  247. procedure send_wcp;
  248. Label
  249.   99;
  250. Var
  251.    UserKey : char;
  252.    c, sectnum, errors : integer;
  253.    bflag : boolean;
  254.  
  255.   function ReadBlock : integer;
  256.   Var
  257.     i, j : integer;
  258.   begin
  259.     FillChar(sector, 133, ^Z);
  260.     sector[1] := SOH;
  261.     sector[2] := sectnum;
  262.     sector[3] := 255 - sectnum;
  263.     crcval := 0;
  264.     i := 4;
  265.     while (not eof(f^)) and (i < 132) do
  266.     begin
  267.       read(f^, sector[i]);
  268.       updcrc(sector[i]);
  269.       i := succ(i)
  270.     end;
  271.     for j := i to 131 do
  272.       updcrc(sector[j]);
  273.     updcrc(0); updcrc(0);
  274.     sector[132] := hi(crcval);
  275.     sector[133] := lo(crcval);
  276.     ReadBlock := i - 4
  277.   end;
  278.  
  279.   procedure SendBlock;
  280.   Var i : integer;
  281.   begin
  282.     for i := 1 to 133 do
  283.       send(sector[i])
  284.   end;
  285.  
  286. begin
  287.      status(2, 'SEND XMODEM');
  288.      SaveCommStatus;
  289.      OpenTemp(1,3,80,8,2);
  290.      repeat
  291.        write('Enter a filename for upload file (<cr> to abort): ');
  292.        readln(fname);
  293.        supcase(fname);
  294.        if length(fname) > 0 then
  295.        begin
  296.          bflag := exists(fname);
  297.          if not bflag then
  298.          begin
  299.            writeln('Could not open file ',fname);
  300.            writeln('(Spelling or drive designation wrong?)');
  301.            writeln
  302.          end
  303.        end
  304.     until bflag or (length(fname) = 0);
  305.     CloseTemp;
  306.     if length(fname) = 0 then
  307.       goto 99;
  308.     f := fopen(fname,'r');
  309.     writeln(^M, ^J, 'Transmitting file: ',fname);
  310.     writeln(LongFileSize(f^):6:0,' bytes, ',int(LongFileSize(f^)/133.0)+1:4:0,' Blocks');
  311.     writeln('Approximate time to send:',
  312.              (int(LongFileSize(f^)/133.0)+1)*22.1666667/speed:6:2,
  313.              ' minutes at',speed:5,' bps.');
  314.     sectnum := 1;
  315.     errors := 0;
  316.     ShowCrt(0,0,0);
  317.     UserKey := #0;
  318.     repeat
  319.       c := cgetc(1);
  320.       if keypressed then read(kbd, UserKey)
  321.     until (c <> -1) or (UserKey = ^X);
  322.     if UserKey = ^X then goto 99;
  323.     UserKey := #0;
  324.     purge;
  325.     while (ReadBlock > 0) and (errors <= MAXERRS) do
  326.     begin
  327.       errors := 0;
  328.       repeat
  329.         ShowCrt(sectnum, errors, 0);
  330.         SendBlock;
  331.         repeat
  332.           c := cgetc(0);
  333.           if KeyPressed then read(kbd,UserKey);
  334.         until (c <> -1) or (UserKey = ^X);
  335.         if UserKey = ^X then goto 99;
  336.         if c = ACK then
  337.           sectnum := sectnum + 1
  338.         else
  339.           errors := errors + 1
  340.       until (c = ACK) or (errors = MAXERRS)
  341.     end;
  342.     errors := 0;
  343.     repeat
  344.       send(EOT);
  345.       repeat
  346.         c := cgetc(10);
  347.         if KeyPressed then read(kbd,UserKey);
  348.       until (c <> -1) or (UserKey = ^X);
  349.       if UserKey = ^X then goto 99;
  350.       if c = NAK then errors := errors + 1
  351.     until (c = ACK) or (errors = MAXERRS);
  352.     99:
  353.     close(f^);
  354.     dispose(f);
  355.     if UserKey = ^X then
  356.     begin
  357.       WriteLn(^M,^J,'Cancelling transmission of ',fname, ' at your request');
  358.       repeat
  359.         send(CAN);
  360.         purge
  361.       until cgetc(1) = -1
  362.     end;
  363.     status(0,' ');
  364.     status(2,'On-Line/Ready');
  365.     dbits        := db;
  366.     parity       := p;
  367.     stop_bits    := sb;
  368.     update_uart
  369. end;
  370.